Developer CD Series 1992 June: ROMin Holiday

home *** CD-ROM | disk | FTP | other *** search

/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / Apple II / Essentials / Dynamo 4.2 for GSBug 1.5b10 / rtfp.a < prev

Wrap

Text File | 1990-09-21 | 14.9 KB | 1,038 lines | [TEXT/MPS ]

**************************************************************** * * * DYNAMO * * * * Apple II 8-bit floating-point runtime library routines. * * Copyright (C) 1990 Apple Computer. * * Version 4.1 * * * * Written by Eric Soldan, Apple II DTS * * * **************************************************************** include ':dynamo.includes:sys.equ' import intspace, floatspace FACEXP equ $9D FACHO equ $9E FACMOH equ $9F FACMO equ $A0 FACLO equ $A1 FACSGN equ $A2 FBUFFR equ $100 GIVAYF equ $E2F2 FSUB equ $E7A7 FADD equ $E7BE LOG equ $E941 FMULT equ $E97F CONUPK equ $E9E3 FDIV equ $EA66 MOVFM equ $EAF9 MOVMF equ $EB2B SGN equ $EB90 ABS equ $EBAF FCOMP equ $EBB2 QINT equ $EBF2 INT equ $EC23 FOUT equ $ED34 SQR equ $EE8D FPWRT equ $EE97 EXP equ $EF09 RND equ $EFAE COS equ $EFEA SIN equ $EFF1 TAN equ $F03A ATN equ $F09E ****************** export startUnary startUnary proc export startUnary0, startUnary1 export startBinary, startBinary0 export endUnBin, endUnBin0, endUnBin1, beginfloat, endfloat, endfloat0 ldy #>floatspace ;Pack and copy float into variable. txa clc adc #<floatspace bcc startUnary0 iny startUnary0 stx endUnBin1+1 ;Preserve xreg. jsr beginfloat jsr MOVFM lda #0 ;Make sure this general flag sta $A4 ;is initialized. sta $D8 ;Make sure AppleSoft ONERR is off. ldx endUnBin1+1 rts startUnary1 jsr beginfloat stx endUnBin1+1 rts startBinary tya ldy #>floatspace ;Pack and copy float into variable. clc adc #<floatspace bcc startBinary0 iny startBinary0 jsr beginfloat stx endUnBin1+1 jsr MOVFM lda #0 ;Make sure this general flag sta $A4 ;is initialized. sta $D8 ;Make sure AppleSoft ONERR is off. ldy #>floatspace lda endUnBin1+1 clc adc #<floatspace bcc @b iny @b rts endUnBin lda #<floatspace clc adc endUnBin1+1 tax lda #>floatspace adc #0 tay jsr MOVMF endUnBin0 jsr endfloat endUnBin1 ldx #0 ;Modified. clc rts beginfloat sta @keepa+1 stx @keepx+1 tsx stx keepstkptr+1 ldx #0 @a lda $0,x sta keepzp,x lda $100,x sta keepstk,x inx bne @a lda cswl sta keepcswl+1 lda cswh sta keepcswh+1 lda #<errhook sta cswl lda #>errhook sta cswh @keepa lda #0 ;Modified. @keepx ldx #0 ;Modified. rts keepzp ds.b 256 keepstk ds.b 256 endfloat ldy #0 ;Restore 0-page and unhook error trap. @a lda keepzp,y sta |$0,y iny bne @a endfloat0 keepcswl lda #0 ;Modified. sta cswl keepcswh lda #0 sta cswh rts errhook jsr endfloat ;Restore 0-page and unhook error trap. txa ;Preserve error code. tay keepstkptr ldx #0 ;Modified. inx inx inx inx txs inx @a lda keepstk,x sta $100,x inx bne @a ldx endUnBin1+1 tya ;Move floating-point error into acc. sec ;Indicate floating-point error occured. rts endp ****************** export i2f i2f proc jsr startUnary1 lda intspace+1,x ;Get variable int value. ldy intspace,x jsr GIVAYF ;Convert a,y int into float (in FAC). jmp endUnBin endp *** export f2i f2i proc jsr startUnary jsr QINT ldx endUnBin1+1 ;Restore xreg. lda FACMO sta intspace+1,x tay lda FACLO sta intspace,x jmp endUnBin0 endp *** export i2fsetconl i2fsetconl proc export i2fsetcon import setcon ldy #0 i2fsetcon jsr setcon jmp i2f endp *** export fout fout proc export fout0 import rtcout jsr startUnary0 fout0 jsr endfloat0 jsr FOUT ldx #0 @a lda FBUFFR,x beq @b jsr rtcout inx bne @a ;Always. @b jmp endUnBin0 endp *** export fvout fvout proc jsr startUnary jmp fout0 endp *** export frtsout frtsout proc pla clc adc #5 sta @a+1 pla adc #0 tay pha @a lda #0 ;Modified. pha sbc #3 ;-4, since carry is clear. bcs @b dey @b jmp fout endp *** export fmulvar fmulvar proc jsr startBinary jsr FMULT ;Do the multiply. jmp endUnBin endp *** export fmulcon fmulcon proc jsr startBinary0 jsr FMULT ;Do the multiply. jmp endUnBin endp *** export frtsmul frtsmul proc pla clc adc #5 sta @a+1 pla adc #0 tay pha @a lda #0 ;Modified. pha sbc #3 ;-4, since carry is clear. bcs @b dey @b jmp fmulcon endp *** export fdivvar fdivvar proc jsr startBinary jsr FDIV ;Do the divide. jmp endUnBin endp *** export fdivcon fdivcon proc jsr startBinary0 jsr FDIV ;Do the divide. jmp endUnBin endp *** export frtsdiv frtsdiv proc pla clc adc #5 sta @a+1 pla adc #0 tay pha @a lda #0 ;Modified. pha sbc #3 ;-4, since carry is clear. bcs @b dey @b jmp fdivcon endp *** export faddvar faddvar proc jsr startBinary jsr FADD ;Do the add. jmp endUnBin endp *** export faddcon faddcon proc jsr startBinary0 jsr FADD ;Do the add. jmp endUnBin endp *** export frtsadd frtsadd proc pla clc adc #5 sta @a+1 pla adc #0 tay pha @a lda #0 ;Modified. pha sbc #3 ;-4, since carry is clear. bcs @b dey @b jmp faddcon endp *** export fsubvar fsubvar proc jsr startBinary jsr FSUB ;Do the subtract. jmp endUnBin endp *** export fsubcon fsubcon proc jsr startBinary0 jsr FSUB ;Do the subtract. jmp endUnBin endp *** export frtssub frtssub proc pla clc adc #5 sta @a+1 pla adc #0 tay pha @a lda #0 ;Modified. pha sbc #3 ;-4, since carry is clear. bcs @b dey @b jmp fsubcon endp *** export fv2v fv2v proc jsr startBinary jsr CONUPK ;Move value into ARG. lda FACEXP ;Get A and Z correct. jsr FPWRT ;Do the exponentation. jmp endUnBin endp *** export fv2con fv2con proc jsr startBinary0 jsr CONUPK ;Move value into ARG. lda FACEXP ;Get A and Z correct. jsr FPWRT ;Do the exponentation. jmp endUnBin endp *** export frtsv2con frtsv2con proc pla clc adc #5 sta @a+1 pla adc #0 tay pha @a lda #0 ;Modified. pha sbc #3 ;-4, since carry is clear. bcs @b dey @b jmp fv2con endp *** export fsgn fsgn proc jsr startUnary jsr SGN ;Get the sign of FAC. jmp endUnBin endp *** export fabs fabs proc jsr startUnary jsr ABS ;Absolute value of FAC. jmp endUnBin endp *** export fint fint proc jsr startUnary jsr INT ;Greatest integer value of FAC. jmp endUnBin endp *** export fsqr fsqr proc jsr startUnary jsr SQR ;Take square root of FAC. jmp endUnBin endp *** export flog flog proc jsr startUnary jsr LOG ;Log base e of FAC. jmp endUnBin endp *** export fexp fexp proc jsr startUnary jsr EXP ;Raise e to FAC power. jmp endUnBin endp *** export frnd frnd proc jsr startUnary jsr CONUPK ;Move value into ARG. jsr @swaplastrnd ;Swap last 'random' number into 0-page. jsr RND ;Forms a 'random' number in FAC. jsr @swaplastrnd jmp endUnBin @swaplastrnd ldx #4 @a lda $C9,x ldy @lastrnd,x sty $C9,x sta @lastrnd,x dex bpl @a rts @lastrnd dc.b 128,79,199,82,89 ;This is the AppleSoft initial 'random' number. endp *** export fcos fcos proc jsr startUnary jsr COS ;COS(FAC). jmp endUnBin endp *** export fsin fsin proc jsr startUnary jsr SIN ;SIN(FAC). jmp endUnBin endp *** export ftan ftan proc jsr startUnary jsr TAN ;TAN(FAC). jmp endUnBin endp *** export fatn fatn proc jsr startUnary jsr ATN ;ARCTAN(FAC). jmp endUnBin endp *** export i2fsetvars i2fsetvars proc pla sta @gv+1 pla sta @gv+2 txa pha @loop jsr @getval cmp #255 beq @exit tax jsr @getval sta floatspace,x jsr @getval sta floatspace+1,x jsr i2f jmp @loop @exit pla tax lda @gv+2 pha lda @gv+1 pha rts @getval inc @gv+1 bne @gv inc @gv+2 @gv lda $2000 ;Address modified. rts endp *** export frtssetcon frtssetcon proc pla sta @gv+1 pla sta @gv+2 txa pha ldy #5 @loop inc @gv+1 bne @gv inc @gv+2 @gv lda $2000 ;Address modified. sta floatspace,x inx dey bne @loop pla tax lda @gv+2 pha lda @gv+1 pha rts endp *** export fsetcon fsetcon proc sta @gv+1 sty @gv+2 txa pha ldy #0 @gv lda $2000,y ;Address modified. sta floatspace,x inx iny cpy #5 bcc @gv pla tax rts endp *** export fsetzero fsetzero proc lda #0 sta floatspace,x sta floatspace+1,x sta floatspace+2,x sta floatspace+3,x sta floatspace+4,x rts endp *** export fsetvars fsetvars proc pla sta @gv+1 pla sta @gv+2 txa pha @loop jsr @getval cmp #255 beq @exit tax ldy #5 @a jsr @getval sta floatspace,x inx dey bne @a beq @loop ;Always. @exit pla tax lda @gv+2 pha lda @gv+1 pha rts @getval inc @gv+1 bne @gv inc @gv+2 @gv lda $2000 ;Address modified. rts endp *** export fvcmp fvcmp proc jsr startBinary jsr FCOMP ;Do the compare. ldx endUnBin0+1 eor #1 cmp #1 rts endp *** export fcmp fcmp proc jsr startBinary0 jsr FCOMP ;Do the compare. ldx endUnBin0+1 eor #1 cmp #1 rts endp *** export frtscmp frtscmp proc pla clc adc #5 sta @a+1 pla adc #0 tay pha @a lda #0 ;Modified. pha sbc #3 ;-4, since carry is clear. bcs @b dey @b jmp fcmp endp *** export readfloat readfloat proc import getdatabyte txa pha ldy #5 @a jsr getdatabyte sta floatspace,x inx dey bne @a pla tax rts endp *** export fvarcpy fvarcpy proc txa pha lda #5 sec @a pha lda floatspace,y iny sta floatspace,x inx pla sbc #1 bne @a pla tax rts endp *** * Step 1: Initialize stuff. * Step 2: Parse the string and get the values of the components. * Step 3: Use the component values to generate a 5-byte float number. * Step 4: Put a pointer to this value in a,y and return. export fstrval fstrval proc export fmidstrval import strinfo, strlen, currentstr, nextchr ldy #0 ;Step 1: Initialize stuff. fmidstrval jsr strinfo sta getchr+1 stx getchr+2 ;Stuff initialized -- step 1 done. lda #0 ;Initialize values. ldx #sgn-exp ;Initialize work values. @init sta exp,x dex bpl @init sec ;Set sgn to $80, instead of 0. ror sgn ;Assume positive. lda #$80+32 ;Initialize exponent. sta exp ;Done with step 1. ;Step 2: Parse string and get values. jsr getchr ;Get first character (good place to start). bcs @b ;It is a digit, so go handle it. cmp #'-' bne @a asl sgn ;It is negative after all. bcs @nextchr ;Always. @a cmp #'+' bne @d ;It isn't a digit or a plus. ;Ignore optional +. @nextchr jsr getchr ;Get next character. bcc @d ;It isn't a digit. @b pha jsr mant10 ;Multiply mantissa by 10. pla and #$0F clc adc mant0 sta mant0 bcc @c inc mant1 bne @c inc mant2 bne @c inc mant3 bne @c inc extmant @c jsr revnorm ;Take care of mantissa overflow, if any. lda dptflg beq @nextchr ;Haven't hit decimal-point yet. inc dptcnt ;Passed decimal-point, so count decimal digit. bne @nextchr ;Always. @d cmp #'.' bne @e ;Not a decimal-point either. lda dptflg bne @m ;Already had a decimal-point, so this one means stop. inc dptflg ;Flag that we hit the decimal-point. bne @nextchr ;Go do more characters. @e ora #$20 ;See if we have an exponent part. cmp #'e' bne @m ;No exponent part. @f jsr getchr ;Get the value of the exponent part. bcs @h ;It is a digit, so go handle it. cmp #'-' ;See if the exponent is negative. bne @g ror expneg ;Set bit 7, since it is negative. bcc @nextexpchr ;Always. @g cmp #'+' bne @m ;It isn't a digit or a plus. ;Ignore optional +. @nextexpchr jsr getchr bcc @m ;It isn't a digit. @h and #$0F sta @expdigit+1 lda expval asl a ;*2 asl a ;*4 adc expval ;*5 asl a ;*10 @expdigit adc #0 ;Modified. sta expval jmp @nextexpchr ;Get next exponent character. ;Done with step 2. ;Step 3: Use the component values to generate ;a 5-byte float number. @m sty nextchr ;Pass back info where we stopped in the string. lda mant0 ;Check for special case of 0. ora mant1 ora mant2 ora mant3 bne @mm ;It is not 0. sta exp beq exit ;It is 0, so we are done. @mm jsr normalize ;Normalize the number. lda expval ;Adjust the exponent value. asl expneg bcc @n ;Exponent positive. eor #$FF ;Change sign of exponent value. adc #0 ;Carry set, so we add 1 here. @n sec sbc dptcnt ;Adjust for number of decimal digits. sta expval ;This is the real exponent value. beq dosgn ;No exponent adjustment necessary. bpl expmul ;For this case, we multiply to adjust for exponent. expdiv ldy #0 ;Divide the mantissa by 10. sty extmant ;Use extended mantissa for divide precision. ldx #40 ;Mantissa is 40 bits. @a tya ;Remainder will be in the y when we are done. asl extmant rol mant0 rol mant1 rol mant2 rol mant3 rol a tay sec sbc #10 bcc @b ;This factor of 10 didn't go into it. tay ;It did go into it, so record that it did. inc extmant @b dex bne @a ;More bits to try. jsr extnormalize ;Normalize extended mantissa. inc expval ;See if we have done enough exponent adjustment. bne expdiv ;More adjusting to go. dosgn lda mant3 eor sgn sta mant3 ;Done with step 3. exit lda #<exp ;Step 4: Return pointer to float value. ldy #>exp ldx currentstr rts expmul jsr mant10 ;Multiply mantissa by 10. jsr revnorm ;Take care of mantissa overflow. dec expval ;See if we have done enough exponent adjustment. bne expmul ;More adjusting to go. beq dosgn ;We be done. revnorm lda extmant beq @rts @a lsr a ;Reverse normalize mantissa. ror mant3 ror mant2 ror mant1 ror mant0 inc exp tax bne @a ;More normalizing to do. bcs incmant ;Round the mantissa. @rts rts *** normalize lda #0 sta extmant extnormalize ldy mant3 bmi rts0 ;Mantissa is normalized to start with. @a dec exp asl extmant rol mant0 rol mant1 rol mant2 rol mant3 bpl @a ;Not normalized yet. lda extmant ;Round the mantissa, if necessary. bpl rts0 ;Not necessary. incmant inc mant0 bne rts0 inc mant1 bne rts0 inc mant2 bne rts0 inc mant3 bne rts0 lda #$FF sta mant0 sta mant1 sta mant2 sta mant3 rts0 rts mant10 lda #0 ;extmant is for overflow extension. sta extmant ldx #-4 ;Push mantissa on stack, hi-byte first. @a lda mant3+4-256,x pha inx bne @a jsr @times2 ;*2 jsr @times2 ;*4 ldx #3 ;*5 @b pla adc mant3,x sta mant3,x dex bpl @b bcc @times2 inc extmant @times2 asl mant0 ;Final time here, *10. rol mant1 rol mant2 rol mant3 rol extmant rts ;Carry clear on exit. getchr lda $2000,y ;Modified. cpy strlen bcs @eos ;We have reached the end of the string. iny cmp #'9'+1 bcs @clc ;Not a digit. cmp #'0' ;Sets carry if it is a digit. rts @eos lda #0 @clc clc @rts rts exp dc.b 0 mant3 dc.b 0 mant2 dc.b 0 mant1 dc.b 0 mant0 dc.b 0 extmant dc.b 0 dptflg dc.b 0 dptcnt dc.b 0 expval dc.b 0 expneg dc.b 0 sgn dc.b 0 endp *** END